home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / wcl-21.lha / wcl-2.1 / src / compiler / common / compile.lisp < prev    next >
Lisp/Scheme  |  1992-09-10  |  15KB  |  457 lines
  1. ;;; (C) Copyright 1990-1992 by Wade L. Hennessey. All rights reserved.
  2.  
  3. (defun comf (file &key
  4.           (output-file (merge-pathnames ".o" file))
  5.           (c-file (merge-pathnames ".c" file))
  6.           (verbose *compile-verbose*)
  7.           (print *compile-print*)
  8.           (config *config*)
  9.           (pic? *pic?*)
  10.           only-to-c?)
  11.   (initialize-compiler)
  12.   (let ((*package* *package*)
  13.     (*const-labels* (make-hash-table :test #'equal))
  14.     (*pic?* pic?)
  15.     (*config* config)
  16.     (*print-base* 10)
  17.     (*print-gensym* t)
  18.     (*input-stream-line-numbers?* (config-lisp-line-numbers? config))
  19.     (*new-function-info* (new-function-info-table 200))
  20.     (*referenced-c-info* nil)
  21.     (input-file (merge-pathnames file ".lisp"))
  22.     (code-file (tmp-file-name ".p"))
  23.     (k-file (tmp-file-name ".k"))
  24.     (package-file (tmp-file-name ".pkg"))
  25.     (win-file (tmp-file-name ".w")))
  26.     (unwind-protect
  27.      (progn
  28.        (with-open-file (input-stream input-file)
  29.          (with-open-file (*package-stream* package-file :direction :output)
  30.            (with-open-file (*c-stream* code-file :direction :output)
  31.          (with-open-file (*win-stream* win-file :direction :output)
  32.            (with-open-file (*k-stream* k-file :direction :output)
  33.              (let ((*compile-file-pathname* (pathname input-stream))
  34.                (*readtable* (if (config-lisp-line-numbers?
  35.                          *config*)
  36.                         *line-number-readtable*
  37.                         *readtable*))
  38.                (*source-table*
  39.                 (make-hash-table :size 300 :test #'equal))
  40.                (*external-procs*
  41.                 (make-hash-table :size 300 :test #'eq)))
  42.                (when verbose
  43.              (format *standard-output* "~&Compiling file ~S~%"
  44.                  *compile-file-pathname*))
  45.                (comf-begin)
  46.                (comf-loop input-stream print)
  47.                (comf-finish)))))))
  48.        (append-files c-file package-file win-file k-file code-file))
  49.       (del-files package-file win-file k-file code-file))
  50.     (if only-to-c?
  51.     (pathname c-file)
  52.     (progn (invoke-c-compiler (namestring c-file)
  53.                   (namestring output-file))
  54.            (when verbose
  55.          (format *standard-output* "~&Wrote object file ~S~%"
  56.              output-file))
  57.            output-file))))
  58.  
  59. (defun comf-begin ()
  60.   (emit-configuration-info)
  61.   (emit-k "#include \"lisp.h\"~%~%"))
  62.  
  63. (defun comf-loop (input-stream print)
  64.   (loop for form = (progn
  65.              (clrhash *source-table*)
  66.              (read input-stream nil input-stream))
  67.     until (eq form input-stream)
  68.     ;; HEY! make print option print something more meaningful
  69.     when print do (princ "Compiling top-level form")
  70.     for init = (comf-top-level-form form)
  71.     unless (null init)
  72.     append init into thunk-body
  73.     finally
  74.     (let ((init-name (file-init-thunk-name input-stream)))
  75.       (unless (null thunk-body)
  76.         (compile-define-function
  77.          (macroexpand-w `(defun ,init-name ()
  78.                   ,@thunk-body)))
  79.         (emit-win ":init ~S~%" init-name))
  80.       (maphash #'(lambda (lisp-name c-name)
  81.                (declare (ignore lisp-name))
  82.                (unless (eq c-name :done)
  83.              (emit-k "extern LP ~A();~%" c-name)))
  84.            *external-procs*))))
  85.  
  86. (defun comf-finish ()
  87.   (emit-k "~%~%")
  88.   (format *package-stream* ":end-package-info 0~%")
  89.   (emit-referenced-c-definitions)
  90.   (when (config-lisp-line-numbers? *config*)
  91.     (emit-k "#line 1 \"~A\"~%"
  92.         (namestring *compile-file-pathname*)))
  93.   (write-procedure-info *new-function-info* *win-stream*)
  94.   (emit-win ":end~%*/~%~%"))
  95.  
  96. (defun emit-configuration-info ()
  97.   (format *package-stream* "/*~%")
  98.   (format *package-stream* ":comment \"Compiled at ")
  99.   (print-time :stream *package-stream*)
  100.   (format *package-stream* "\"~%")
  101.   (format *package-stream* ":comment \"Compiler Configuration: ~A\"~%"
  102.       (config-name *config*))
  103.   (format *package-stream* ":comment \"Machine Configuration: ~A\"~%"
  104.       (machine-name *target-machine*))
  105.   (format *package-stream* ":comment \"cc command: ~A\"~%"
  106.       (basic-cc-string))
  107.   (format *package-stream* ":version ~A~%" 0))
  108. (defun comf-top-level-form (form)
  109.   (if (atom form)
  110.       nil
  111.       (let ((mexp (macroexpand-w form))
  112.         (*current-line* (if (config-lisp-line-numbers? *config*)
  113.                 (source-line form)
  114.                 nil)))
  115.     (case (car mexp)
  116.       (define-function (compile-define-function mexp))
  117.       (define-variable (compile-define-var mexp))
  118.       (define-macro (compile-define-macro mexp))
  119.       (define-type (compile-define-type mexp))
  120.       (define-compiler-macro-1 (compile-define-compiler-macro-1 mexp))
  121.       (define-structure (compile-top-level-define-structure mexp))
  122.       (define-c-structure (compile-top-level-define-c-structure mexp))
  123.       (define-c-type-name (compile-top-level-define-c-type-name mexp))
  124.       (define-foreign-function
  125.           (compile-top-level-define-foreign-function mexp))
  126.       (define-setf (compile-top-level-define-setf mexp))
  127.       (proclaim (compile-top-level-proclaim mexp))
  128.       (progn (compile-top-level-progn mexp))
  129.       (eval-when (compile-top-level-eval-when mexp))
  130.       (in-package (compile-top-level-package-related-form mexp))
  131.       (add-winfo (compile-top-level-add-winfo mexp))
  132.       (t (list mexp))))))
  133.  
  134. (defun compile-top-level-add-winfo (form)
  135.   (emit-win (second form))
  136.   (emit-win "~%")
  137.   nil)
  138.  
  139. (defun compile-top-level-package-related-form (form)
  140.   (format *package-stream* ":package ~S ~%" form)
  141.   (eval form)
  142.   nil)
  143.  
  144. (defun compile-top-level-progn (form)
  145.   (loop for x in (cdr form)
  146.     for init = (comf-top-level-form x)
  147.     unless (null init)
  148.     append init into thunk-body
  149.     finally (return thunk-body)))
  150.  
  151. (defun compile-top-level-eval-when (form)
  152.   (destructuring-bind (ignore when . body) form
  153.     (declare (ignore ignore))
  154.     (when (member 'compile when)
  155.       (eval `(progn ,@body)))
  156.     (if (member 'load when)
  157.     (comf-top-level-form `(progn ,@body))
  158.     nil)))
  159.  
  160.  
  161. (defun compile-top-level-define-c-type-name (form)
  162.   (destructuring-bind (define-c-type-name (q1 name) (q2 type)) form
  163.     (declare (ignore define-c-type-name q1 q2))
  164.     (emit-win ":c-type ~S ~S~%" name type)
  165.     (define-c-type-name name type)
  166.     nil))
  167.  
  168. (defun compile-top-level-define-foreign-function (form)
  169.   (eval form)
  170.   nil)
  171.  
  172. (defun compile-define-function (form)
  173.   (destructuring-bind (define-function (q1 name) kind
  174.             (q3 in-types) (q4 out-types)
  175.             (q5 body)
  176.             function-with-type-checks
  177.             function) form
  178.     (declare (ignore define-function q1 q2 q3 q4 q5))
  179.     (when (lookup-macro-expander name *macro-expanders* nil)
  180.       (remove-macro-expander name)
  181.       (warn "Redefining macro ~A as a function" name))
  182.     (let ((real-function
  183.        (if (and (eq kind :defmethod)
  184.             (config-full-type-checking? *config*))
  185.            function-with-type-checks
  186.            function)))
  187.       (let ((flabel (com-1 real-function)))
  188.     (unless (null flabel)
  189.       (add-proc-definition
  190.        name body function *compile-file-pathname*)
  191.       (when (eq kind :defmethod)
  192.         (proclaim-ftype-info name in-types out-types))
  193.       (emit-win ":sf ~S ~S~%" name flabel)))
  194.       nil)))
  195.  
  196. (defun compile-define-macro (form)
  197.   (eval form)    
  198.   (destructuring-bind (define-macro
  199.               (q1 name)
  200.               (f1 function))
  201.       form
  202.     (declare (ignore define-macro q2 f1 q1))
  203.     (let ((flabel (com-1 `(named-macro-function ,name ,function))))
  204.       (emit-win ":sm ~S ~S~%" name flabel)
  205.       (list `(define-macro ',name #',name)))))
  206.  
  207. (defun compile-define-type (form)
  208.   (eval form)
  209.   (list form))
  210.  
  211. (defun compile-define-compiler-macro-1 (form)
  212.   (eval form)    
  213.   (list form))
  214.  
  215. (defun compile-top-level-define-setf (form)
  216.   (eval form)
  217.   ;; this sometimes breaks kcl
  218.   (list form))
  219.  
  220. (defun compile-top-level-define-structure (form)
  221.   (let ((info (second form))
  222.     (*print-structure* t))
  223.     (let ((*print-array* t))
  224.       (emit-win ":structure ~S ~S~%"
  225.         info
  226.         (lisp->c-proc-name (fluid-predicate-name info))))
  227.     (define-structure info)
  228.     (list form)))
  229.  
  230.  
  231. (defun compile-top-level-define-c-structure (form)
  232.   (let ((info (second form))
  233.     (*print-structure* t)
  234.     (*print-array* t))
  235.     (emit-win ":c-type ~S ~S~%" (c-struct-info-name info) info)
  236.     (define-c-structure info)
  237.     nil))
  238.  
  239. (defun compile-define-var (form)
  240.   (destructuring-bind (i0 (i1 name) init-form doc-string type) form
  241.     (declare (ignore i0 i1 doc-string))
  242.     (ecase type
  243.       ((:var :parameter) (proclaim-special-variable name))
  244.       (:constant (proclaim-constant-variable name init-form)))
  245.     (if (simple-constant? init-form)
  246.     (progn (emit-win "~S ~S ~S~%"
  247.              (if (eq type :constant) :sc :sv) name init-form)
  248.            nil)
  249.     (list form))))
  250.  
  251. (defun simple-constant? (x)
  252.   ;; HEY! add vector and quoted list support. Add general quoted object stuff.
  253.   ;; Have to emit all subobjects of the constant (i.e symbols)
  254.   ;; as well as the constant. 
  255.   (or (stringp x) (numberp x)))
  256.  
  257. (defun com-1 (form)
  258.   (let* ((*proc-chain* nil)
  259.      (tree (analyze form)))
  260.     (if (null tree)
  261.     (warn "Not emitting c code for ~A" (form-name form))
  262.     (if (top-level-proc-p tree)
  263.         (let ((*emitting-proc?* nil))
  264.           (back-end tree))
  265.         (error "Only expect top-level-procs at top-level")))))
  266.  
  267. (defun back-end (tree)
  268.   (when (config-beta? *config*)
  269.     (beta tree nil))
  270.   (improve tree)
  271.   (emit-code tree))
  272.  
  273. (defun compile-top-level-proclaim (form)
  274.   (destructuring-bind (ignore-1 decl-spec) form
  275.     (declare (ignore ignore-1))
  276.     (proclaim-w (eval decl-spec))
  277.     (emit-win ":proclaim ~S~%" decl-spec)
  278.     nil))
  279.  
  280. (defun proclaim-w (decl-spec)
  281.   (let ((decl (car decl-spec))
  282.     (spec (cdr decl-spec)))
  283.     (case decl
  284.       (optimize (loop for (quality value) in spec
  285.               do (case quality
  286.                (speed (setf *config*
  287.                     (ecase value
  288.                       ((0 1 2)  *default-config*)
  289.                       (3 *fastest-config*))))
  290.                (safety nil))))
  291.       (declaration (loop for decl in spec
  292.              do (pushnew decl *ok-foreign-declarations*)))
  293.       (special (loop for special in spec
  294.              do (proclaim-special-variable special)))
  295.       (inline (loop for name in spec do (proclaim-inline-function name)))
  296.       (notinline (loop for name in spec
  297.                do (proclaim-notinline-function name)))
  298.       (type (loop with type = (first spec)
  299.           for var in (rest spec) do
  300.           (proclaim-variable-type var type)))
  301.       ;; Punt for now. Maybe add ANSI interp later.
  302.       (function (let ((function-names spec))
  303.           (when (listp (second function-names))
  304.             (warn "Ignoring obsolete Cltl1 style declaration: ~S"
  305.               decl-spec))))
  306.       (ftype (destructuring-bind ((function in-types out-type) . names)
  307.          spec
  308.            (declare (ignore function))
  309.            (let ((out-types (if (listp out-type) ; (values ...) ?
  310.                     (cdr out-type) 
  311.                     (list out-type))))
  312.          (loop for name in names
  313.                do (proclaim-ftype-info name in-types out-types)))))
  314.       (t (if (member decl *standard-type-specifier-symbols*)
  315.          ;; HEY! record type info
  316.          nil
  317.          (unless (member decl *ok-foreign-declarations*)
  318.            (error "Unknown declaration ~A" decl-spec)))))
  319.     t))
  320.  
  321. (defun get-variable-info (name)
  322.   (gethash name *variable-info*))
  323.  
  324. (defun get-or-create-variable-info (name)
  325.   (or (get-variable-info name)
  326.       (setf (gethash name *variable-info*)
  327.         (make-variable-info :name name))))
  328.  
  329. (defun proclaim-variable-type (variable type)
  330.   (setf (variable-info-type (get-or-create-variable-info variable))
  331.     type))
  332.  
  333. (defun special-var-p (var)
  334.   (lookup-special-decl var (lex-env-decls *env*)))
  335.  
  336. (defun compiler-warn (string &rest args)
  337.   (incf *analysis-errors*)
  338.   (when (= *analysis-errors* 1)
  339.     (format *error-output*
  340.         "~%The following errors were detecting in the ~A:~% "
  341.         (form-name (lex-env-outermost-form *env*))))
  342.   (format *error-output* "~8T~A~%" (apply #'format nil string args))
  343.   (when *break-on-compiler-warn?* (break))
  344.   nil)
  345.  
  346. (defun w-warn (string &rest args)
  347.   (apply #'format *error-output* string args)
  348.   nil)
  349.  
  350. (defun form-name (form)
  351.   (or (and (listp form)
  352.        (case (first form)
  353.          (named-function (format nil "function ~A" (second form)))
  354.          (define-variable (format nil "global variable~A" (second form)))))
  355.       (let ((*print-level* 3)
  356.         (*print-length* 3))
  357.     (format nil "Top Level Form ~A" form))))
  358.  
  359. (defun initialize-compiler ()
  360.   (initialize-function-info-table)
  361.   (setf (c-compiler-command *sun-cc*)    ; set here for correct tmp dir
  362.     (format nil "cc -w -temp=~A " (tmpdir)))
  363.   (unless *compiler-initialized?*
  364.     (setf *target-machine* (default-target-machine))
  365.     (read-all-libraries-compiler-info)
  366.     ;; Add primitive, compiler-macro, and compiler-method inits.
  367.     (initialize-function-methods)
  368.     (setf *compiler-initialized?* t)))
  369.  
  370. (defun default-target-machine ()
  371.   #.(let ((machine-type (processor+os->machine-type
  372.              (installation-parameter "PROCESSOR")
  373.              (installation-parameter "OPERATING_SYSTEM")))
  374.       (cc (installation-parameter "CC")))
  375.       (case machine-type
  376.     (:sun-4 (cond ((string-equal cc "gcc") *sparcstation-gcc*)
  377.               ((string-equal cc "cc") *sparcstation-cc*)))
  378.     (:decstation *decstation*))))
  379.  
  380. (defun tmp-file-name (format-string &rest args)
  381.   (pathname (format nil "~A/~D-~D~A"
  382.             (tmpdir)
  383.             (getpid)
  384.             (incf *tmp-file-counter*)
  385.             (apply #'format nil format-string args))))
  386.  
  387. (defun del-files (&rest files)
  388.   (loop for f in files
  389.     when (probe-file f)
  390.     do (delete-file f)))
  391.  
  392. (defun del-derived-files (&rest files)
  393.   (loop for file in files
  394.     do (del-files file
  395.               (merge-pathnames ".o" file)
  396.               (merge-pathnames ".c" file))))
  397.  
  398. (defun append-files (dest &rest sources)
  399.   (shell (format nil "cat ~{ ~A ~} > ~A"
  400.          (mapcar #'namestring sources)
  401.          (namestring dest))))
  402.  
  403. (defun file-init-thunk-name (pathname)
  404.   (gentemp (format nil "~A_INIT" (string-upcase (pathname-name pathname)))))
  405.  
  406.  
  407. #+NATIVE-WCL
  408. (defun compile-file (&rest args)
  409.   (apply #'comf args))
  410.  
  411. #+NATIVE-WCL
  412. (defun compile (name &optional definition)
  413.   (let* ((real-name (if (null name) (gentemp "ANONYMOUS") name))
  414.      (def (if (null definition)
  415.           (function-lambda-expression name)
  416.           (setf (get real-name :function-definition)
  417.             `(defun ,real-name ,@(cdr definition))))))
  418.     (compile-and-load-def def)
  419.     (if (null name)
  420.     (symbol-function real-name)
  421.     name)))
  422.  
  423. #+NATIVE-WCL
  424. (defun compile-and-load-def (def)
  425.   (let ((tmp-file (tmp-file-name "compile.lisp")))
  426.     (unwind-protect
  427.      (progn (with-open-file (output tmp-file :direction :output)
  428.           (print def output))
  429.         (load (compile-file tmp-file :verbose nil)
  430.               :verbose nil))
  431.       ;; Leave all files around for debugging purposes
  432.       ;; (del-files (make-pathname :defaults tmp-file :type "o"))
  433.       nil)))
  434.  
  435. (defun find-root-directory ()
  436.   (let ((cl-lib-file (format nil "libcl.so.~A" *cl-version*)))
  437.     (dolist (dir (unix->lisp-path-list (getenv "LD_LIBRARY_PATH")))
  438.       (let ((dir-name (concatenate 'string (namestring dir) "/")))
  439.     (when (probe-file (merge-pathnames cl-lib-file dir-name))
  440.       (if (char= (aref dir-name 0) #\/)
  441.           (return (pathname
  442.                (concatenate
  443.             'string
  444.             (subseq dir-name
  445.                 0
  446.                 (position #\/ dir-name
  447.                       :end (1- (length dir-name))
  448.                       :from-end t))
  449.             "/")))
  450.           (warn "Need full pathname in LD_LIBRARY_PATH instead of ~S"
  451.             dir-name)))))))
  452.  
  453. (pushnew :compiler *features*)
  454.  
  455.  
  456.  
  457.